home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / emit-data.lisp < prev    next >
Lisp/Scheme  |  1992-09-10  |  9KB  |  259 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. ;;; Emit object x and all of it's sub-objects.
  4. ;;; Returns a string of C code which references the object.
  5. (defun emit-data (x)
  6.   (cond ((wcl-fixnum? x) nil)
  7.     ((characterp x) (format nil "char_tab[~D]" (char-code x)))
  8.     (t (let ((label (gethash x *const-labels*)))
  9.          (if (null label)
  10.          (typecase x
  11.            (symbol
  12.             (let ((label (lisp->c-symbol-name x)))
  13.               (if (null *emit-symbol-data-function*)
  14.               (emit-win ":sym ~S~%" x)
  15.               (funcall *emit-symbol-data-function* x))
  16.               (emit-k "extern SYMBOL ~A; ~%" label)
  17.               (setf (gethash x *const-labels*) label)))
  18.            (t (let ((label (genstring "k")))
  19.             ;; for circ consts
  20.             (setf (gethash x *const-labels*) label) 
  21.             (etypecase x
  22.               (vector (emit-vector label x))
  23.               (array (emit-multi-array label x))
  24.               (inner-proc
  25.                (emit-null-oe-proc label x))
  26.               (foreign-symbol (emit-foreign-symbol x))
  27.               (cons (emit-cons label x))
  28.               (float (emit-float label x))    
  29.               (ratio (emit-ratio label x))
  30.               (complex (emit-complex label x))
  31.               (compiled-function
  32.                (emit-compiled-function label x))
  33.               (structure (emit-structure label x))
  34.               #-native-wcl
  35.               (byte-specifier (emit-cross-byte-specifier label x))
  36.               (integer (emit-bignum label x)))
  37.             label)))
  38.          label)))))
  39.  
  40. (defun emit-lref (x)
  41.   (if (wcl-fixnum? x)
  42.       (format nil "(LP) ~D" (ash x 1))
  43.       (format nil "LREF(~A)" (emit-data x))))
  44.  
  45. (defun emit-foreign-symbol (x)
  46.   x (error "fix"))
  47.  
  48. (defun emit-float (label x)
  49.   (emit-k "MAKE_FLOAT(~A,~F);~%" label x))
  50.  
  51. (defun emit-ratio (label x)
  52.   (let ((numerator (emit-lref (numerator x)))
  53.     (denominator (emit-lref (denominator x))))
  54.   (emit-k "MAKE_RATIO(~A,~A,~A);~%" label numerator denominator)))
  55.  
  56. (defun emit-complex (label x)
  57.   (let ((real (emit-lref (realpart x)))
  58.     (imag (emit-lref (imagpart x))))
  59.   (emit-k "MAKE_COMPLEX(~A,~A,~A);~%" label real imag)))
  60.  
  61. (defun emit-cons (label x)
  62.   (let ((car (emit-lref (car x)))
  63.     (cdr (emit-lref (cdr x))))
  64.     (emit-k "MAKE_CONS(~A,~A,~A);~%" label car cdr)))
  65.  
  66. (defun emit-null-oe-proc (label x)
  67.   (emit-k "MAKE_PROCEDURE(~A,~A);~%" label (proc-c-name x)))
  68.  
  69. (defun emit-vector (label x)
  70.   (cond ((simple-string-p x) (emit-simple-string label x))
  71.     ((simple-array-p x) (emit-simple-1d-array label x))
  72.     (t (emit-complex-1d-array label x))))
  73.  
  74. (defun emit-multi-array (label x)
  75.   (if (simple-array-p x)
  76.       (emit-simple-multi-array label x)
  77.       (emit-complex-multi-array label x)))
  78.  
  79. (defun emit-string-using-c-syntax (string)
  80.   (write-char #\" *k-stream*)
  81.   (loop for c being the array-elements of string do
  82.     (case c
  83.       (#\newline (write-string "\\n" *k-stream*))
  84.       (#\\ (write-string "\\\\" *k-stream*))
  85.       (#\" (write-string "\\\"" *k-stream*))
  86.       (t (write-char c *k-stream*))))
  87.   (write-char #\" *k-stream*))
  88.  
  89. (defun emit-simple-string (label x)
  90.   (let ((len (length x)))
  91.     (if (< len 80)
  92.     (progn (emit-k "MAKE_SIMPLE_STRING(~A,~D," label len)
  93.            (emit-string-using-c-syntax x)
  94.            (emit-k ");~%"))
  95.     ;; ARGHH!!! We cannot use MAKE_SIMPLE_STRING because the losing
  96.     ;; MIPS cpp(1.31) will only pass strings of <= 80 chars as args!!!
  97.     (progn
  98.       (emit-k "static struct {unsigned long header; char string[~D+1];}~%"
  99.           len)
  100.       (emit-k "~A  = {((~D << 8) + TYPE_SIMPLE_STRING), ~%"label len)
  101.       (emit-string-using-c-syntax x)
  102.       (emit-k "};~%")))))
  103.  
  104. (defun emit-simple-1d-array (label x)
  105.   (multiple-value-bind (element-type-tag element-size default-initial-value)
  106.       (type->element-type-tag (array-element-type x))
  107.     (declare (ignore default-initial-value))
  108.     (let* ((objects (if (= element-type-tag element-type-bit)
  109.             (bit-vector->word-list x)
  110.             (loop for e being the elements of x
  111.                   collect (if (= element-type-tag element-type-ptr)
  112.                       (emit-lref e)
  113.                       e))))
  114.        (object-len (length objects)))
  115.       (declare (ignore default-initial-value))
  116.       ;; Sun CC doesn't like 0 element arrays, so we include an unused
  117.       ;; element (gcc doesn't seem to care). This is consistent with
  118.       ;; zero length heap allocated vectors, although static vectors
  119.       ;; don't really need the extra space since they will never be
  120.       ;; converted to a forwarding pointer.
  121.       (let ((c-type  (select element-size
  122.                (1 "unsigned long")
  123.                (8 "unsigned char")
  124.                (16 "unsigned short")
  125.                (32 "LP")
  126.                (64 "unsiged double"))))
  127.     (emit-k "static struct {unsigned long header; ~A cells[~D];} ~%"
  128.         c-type
  129.         (if (= object-len 0) 1 object-len))
  130.     (emit-k "~A = {0x~X, ~%{"
  131.         label
  132.         (+ (ash (length x) 8) element-type-tag))
  133.     (if (= object-len 0)
  134.         (emit-k " 0 ")
  135.         (loop for rest on objects
  136.           unless (eq rest objects) do (emit-k ",")
  137.           do (emit-k "((~A)~A)" c-type (car rest))))
  138.     (emit-k "}};~%")))))
  139.  
  140. #-native-wcl
  141. (defun bit-vector->word-list (bits)
  142.   (declare (ignore bits))
  143.   (error "Cannot cross-emit bit vectors"))
  144.  
  145. #+native-wcl
  146. ;;; This should be byte-order independent, since words are words....
  147. (defun bit-vector->word-list (bit-vector)
  148.   (loop with word-len = (/ (object-size bit-vector) 4)
  149.     with word-vector = (make-array word-len
  150.                        :displaced-to bit-vector
  151.                        :element-type '(unsigned-byte 32))
  152.     for i from 0 below word-len
  153.     collect (aref word-vector 0)))
  154.  
  155. (defun emit-complex-1d-array (label x)
  156.   label x
  157.   (error "write complex-1d array emitter"))
  158.  
  159. (defun emit-complex-multi-array (label x)
  160.   label x
  161.   (error "write complex multi-array emitter"))
  162.  
  163. #-native-wcl
  164. (defun emit-simple-multi-array (label x)
  165.   (declare (ignore label x))
  166.   (warn "Cannot cross-emit simple array ~A, emitting a string instead" x)
  167.   (emit-simple-string label "foobar"))
  168.  
  169. #+native-wcl
  170. (defun emit-simple-multi-array (label x)
  171.   (let ((header (object-header x))
  172.     (underlying-vector (emit-lref (array-underlying-vector x)))
  173.     (dims-vector (emit-lref (array-dims-vector x)))
  174.     (multiplier-vector (emit-lref (array-multiplier-vector x))))
  175.     (emit-k "static SIMPLE_MULTI_ARRAY ~A = " label)
  176.     (emit-k "{0x~X, ~A, ~A, ~A};~%"
  177.         header
  178.         underlying-vector
  179.         dims-vector
  180.         multiplier-vector)))
  181.  
  182. #-native-wcl
  183. (defun ref-structure-as-vector (s i)
  184.   #+kcl (si:structure-ref1 s i)
  185.   #+lucid (system:structure-ref s i (type-of s)))
  186.  
  187. #-native-wcl
  188. (defun compiled-function-name (f)
  189.   #+kcl (si:compiled-function-name f)
  190.   #+lucid (system::procedure-name f))
  191.  
  192. (defun emit-compiled-function (label x)
  193.   (let ((c-name (lisp->c-proc-name (compiled-function-name x))))
  194.     (emit-k "~%extern LP ~A();~%" c-name)
  195.     (emit-k "MAKE_PROCEDURE(~A,~A);~%" label c-name)))
  196.  
  197. #-native-wcl
  198. ;;; Bletch. Cross compilation hack to emit constant byte specifiers
  199. ;;; as a structure.
  200. (defun emit-cross-byte-specifier (label x)
  201.   (let* ((len 3)
  202.      (type-label (emit-lref 'byte))
  203.      (objects (list (emit-lref (byte-size x))
  204.             (emit-lref (byte-position x)))))
  205.     (emit-k "static struct {unsigned long header; LP type;")
  206.     (emit-k "LP cells[~D];} ~%" len)
  207.     (emit-k "~A = {((~D << 8) + TYPE_STRUCTURE), ~A,~%{"
  208.         label len type-label)
  209.     (loop for rest on objects
  210.       unless (eq rest objects) do (emit-k ",")
  211.       do (emit-k "~A" (car rest)))
  212.     (emit-k "}};~%")))
  213.  
  214. (defun emit-structure (label s)
  215.   (let* ((name (type-of s))
  216.      (info (lookup-structure-info name)))
  217.     (if (null info)
  218.     (error "No structure info found for ~A" name)
  219.     (let* ((len (struct-info-length info))
  220.            (type-label (emit-lref (struct-info-name info)))
  221.            (objects (loop for i from 0 below (1- len)
  222.                   collect (emit-lref
  223.                        (ref-structure-as-vector s i)))))
  224.       (emit-k "static struct {unsigned long header; LP type;")
  225.       (emit-k "LP cells[~D];} ~%" len)
  226.       (emit-k "~A = {((~D << 8) + TYPE_STRUCTURE), ~A,~%{"
  227.           label len type-label)
  228.       (loop for rest on objects
  229.         unless (eq rest objects) do (emit-k ",")
  230.         do (emit-k "~A" (car rest)))
  231.       (emit-k "}};~%")))))
  232.  
  233.  
  234. (defun wcl-fixnum? (n)
  235.   #+native-wcl (fixnump n)
  236.   #-native-wcl (and (integerp n) (<= n 1073741823) (>= n -1073741824))
  237.   )
  238.  
  239. (defun emit-bignum (label n)
  240.   (let* ((abs (abs n))
  241.      (hex-digits (write-to-string abs :base 16))
  242.      (len (length hex-digits))
  243.      (bignum-len (ceiling len 8))
  244.      (header-len (+ (* bignum-len 4) 8))
  245.      (header (+ type-bignum (ash header-len 8))))
  246.     (emit-k
  247.      "static struct {unsigned long header; unsigned long len; ~
  248.                      int sign; unsigned long digits[~D];} "
  249.      bignum-len)
  250.     (emit-k"~A = ~%{0x~X, ~D, ~D, {" label header bignum-len (if (> n 0) 1 -1))
  251.     (loop for high from len downto 0 by 8
  252.       for i from (1- bignum-len) downto 0
  253.       do (progn (emit-k "0x~X~A"
  254.                 (subseq hex-digits (max (- high 8) 0) high)
  255.                 (if (= i 0) "" ","))))
  256.     (emit-k "}};~%")))
  257.  
  258.  
  259.